{4:}program PKtoGF(input,output);label{5:}9999;
{:5}const{6:}namelength=80;terminallinelength=132;maxcounts=400;
{:6}type{9:}ASCIIcode=32..126;{:9}{10:}textfile=packed file of char;
{:10}{38:}eightbits=0..255;bytefile=packed file of eightbits;
{:38}var{11:}xord:array[char]of ASCIIcode;xchr:array[0..255]of char;
{:11}{39:}gffile,pkfile:bytefile;
{:39}{41:}gfname,pkname:packed array[1..namelength]of char;
gfloc,pkloc:integer;{:41}{48:}i,j:integer;endofpacket:integer;
dynf:integer;car:integer;tfmwidth:integer;xoff,yoff:integer;
{:48}{50:}comment:packed array[1..17]of char;magnification:integer;
designsize:integer;checksum:integer;hppp,vppp:integer;
{:50}{55:}cheight,cwidth:integer;wordwidth:integer;
horesc,veresc:integer;packetlength:integer;lasteoc:integer;
{:55}{57:}minm,maxm,minn,maxn:integer;mminm,mmaxm,mminn,mmaxn:integer;
charpointer,stfmwidth:array[0..255]of integer;
shoresc,sveresc:array[0..255]of integer;thischarptr:integer;
{:57}{63:}inputbyte:eightbits;bitweight:eightbits;nybble:eightbits;
rowcounts:array[0..maxcounts]of integer;rcp:integer;
{:63}{67:}countdown:integer;done:boolean;max:integer;
repeatcount:integer;xtogo,ytogo:integer;turnon,firston:boolean;
count:integer;curn:integer;{:67}{69:}flagbyte:integer;
{:69}procedure initialize;var i:integer;
begin writeln(output,'This is PKtoGF, Version 1.1');
{12:}for i:=0 to 31 do xchr[i]:='?';xchr[32]:=' ';xchr[33]:='!';
xchr[34]:='"';xchr[35]:='#';xchr[36]:='$';xchr[37]:='%';xchr[38]:='&';
xchr[39]:='''';xchr[40]:='(';xchr[41]:=')';xchr[42]:='*';xchr[43]:='+';
xchr[44]:=',';xchr[45]:='-';xchr[46]:='.';xchr[47]:='/';xchr[48]:='0';
xchr[49]:='1';xchr[50]:='2';xchr[51]:='3';xchr[52]:='4';xchr[53]:='5';
xchr[54]:='6';xchr[55]:='7';xchr[56]:='8';xchr[57]:='9';xchr[58]:=':';
xchr[59]:=';';xchr[60]:='<';xchr[61]:='=';xchr[62]:='>';xchr[63]:='?';
xchr[64]:='@';xchr[65]:='A';xchr[66]:='B';xchr[67]:='C';xchr[68]:='D';
xchr[69]:='E';xchr[70]:='F';xchr[71]:='G';xchr[72]:='H';xchr[73]:='I';
xchr[74]:='J';xchr[75]:='K';xchr[76]:='L';xchr[77]:='M';xchr[78]:='N';
xchr[79]:='O';xchr[80]:='P';xchr[81]:='Q';xchr[82]:='R';xchr[83]:='S';
xchr[84]:='T';xchr[85]:='U';xchr[86]:='V';xchr[87]:='W';xchr[88]:='X';
xchr[89]:='Y';xchr[90]:='Z';xchr[91]:='[';xchr[92]:='\';xchr[93]:=']';
xchr[94]:='^';xchr[95]:='_';xchr[96]:='`';xchr[97]:='a';xchr[98]:='b';
xchr[99]:='c';xchr[100]:='d';xchr[101]:='e';xchr[102]:='f';
xchr[103]:='g';xchr[104]:='h';xchr[105]:='i';xchr[106]:='j';
xchr[107]:='k';xchr[108]:='l';xchr[109]:='m';xchr[110]:='n';
xchr[111]:='o';xchr[112]:='p';xchr[113]:='q';xchr[114]:='r';
xchr[115]:='s';xchr[116]:='t';xchr[117]:='u';xchr[118]:='v';
xchr[119]:='w';xchr[120]:='x';xchr[121]:='y';xchr[122]:='z';
xchr[123]:='{';xchr[124]:='|';xchr[125]:='}';xchr[126]:='~';
for i:=127 to 255 do xchr[i]:='?';
{:12}{13:}for i:=0 to 127 do xord[chr(i)]:=32;
for i:=32 to 126 do xord[xchr[i]]:=i;
{:13}{51:}comment:='PKtoGF 1.1 output';{:51}{58:}mminm:=999999;
mminn:=999999;mmaxm:=-999999;mmaxn:=-999999;
for i:=0 to 255 do charpointer[i]:=-1;{:58}end;
{:4}{8:}procedure jumpout;begin goto 9999;end;
{:8}{40:}procedure opengffile;begin rewrite(gffile,gfname);gfloc:=0;end;
procedure openpkfile;begin reset(pkfile,pkname);pkloc:=0;end;
{:40}{42:}procedure gfbyte(i:integer);begin gffile^:=i;put(gffile);
gfloc:=gfloc+1;end;{:42}{43:}function pkbyte:eightbits;
var nybble,temp:eightbits;begin temp:=pkfile^;get(pkfile);
pkloc:=pkloc+1;pkbyte:=temp;end;{:43}{45:}function signedbyte:integer;
var a:integer;begin a:=pkbyte;if a>127 then a:=a-256;signedbyte:=a;end;
function get16:integer;var a:integer;begin a:=pkbyte;
get16:=a*256+pkbyte;end;function signed16:integer;var a:integer;
begin a:=signedbyte;signed16:=a*256+pkbyte;end;function get32:integer;
var a:integer;begin a:=get16;if a>32767 then a:=a-65536;
get32:=a*65536+get16;end;{:45}{46:}procedure gfsbyte(i:integer);
begin if i<0 then i:=i+256;gfbyte(i);end;procedure gf16(i:integer);
begin gfbyte(i div 256);gfbyte(i mod 256);end;procedure gf24(i:integer);
begin gfbyte(i div 65536);gf16(i mod 65536);end;
procedure gfquad(i:integer);
begin if i>=0 then begin gfbyte(i div 16777216);
end else begin i:=(i+1073741824)+1073741824;
gfbyte(128+(i div 16777216));end;gf24(i mod 16777216);end;
{:46}{62:}function getnyb:integer;var temp:eightbits;
begin if bitweight=0 then begin inputbyte:=pkbyte;bitweight:=16;end;
temp:=inputbyte div bitweight;inputbyte:=inputbyte-temp*bitweight;
bitweight:=bitweight div 16;getnyb:=temp;end;function getbit:boolean;
var temp:boolean;begin bitweight:=bitweight div 2;
if bitweight=0 then begin inputbyte:=pkbyte;bitweight:=128;end;
temp:=inputbyte>=bitweight;if temp then inputbyte:=inputbyte-bitweight;
getbit:=temp;end;{30:}function pkpackednum:integer;var i,j,k:integer;
begin i:=getnyb;if i=0 then begin repeat j:=getnyb;i:=i+1;until j<>0;
while i>0 do begin j:=j*16+getnyb;i:=i-1;end;
pkpackednum:=j-15+(13-dynf)*16+dynf;
end else if i<=dynf then pkpackednum:=i else if i<14 then pkpackednum:=(
i-dynf-1)*16+getnyb+dynf+1 else begin if i=14 then repeatcount:=
pkpackednum else repeatcount:=1;pkpackednum:=pkpackednum;end;end;
{:30}{:62}{70:}procedure skipspecials;var i,j,k:integer;
begin thischarptr:=gfloc;repeat flagbyte:=pkbyte;
if flagbyte>=240 then case flagbyte of 240,241,242,243:begin i:=0;
gfbyte(flagbyte-1);for j:=240 to flagbyte do begin k:=pkbyte;gfbyte(k);
i:=256*i+k;end;for j:=1 to i do gfbyte(pkbyte);end;
244:begin gfbyte(243);gfquad(get32);end;245:begin end;246:begin end;
247,248,249,250,251,252,253,254,255:begin writeln(output,' ',
'Unexpected ',flagbyte:1,'!');jumpout;end;end;
until(flagbyte<240)or(flagbyte=245);end;{:70}{72:}procedure dialog;
var i:integer;buffer:packed array[1..namelength]of char;
begin for i:=1 to namelength do begin gfname[i]:=' ';pkname[i]:=' ';end;
write(output,'Input file name:  ');begin end;
if eoln(input)then readln(input);i:=1;
while not(eoln(input)or eof(input))do begin pkname[i]:=input^;i:=i+1;
get(input);end;pkname[i]:=' ';write(output,'Output file name:  ');
begin end;if eoln(input)then readln(input);i:=1;
while not(eoln(input)or eof(input))do begin gfname[i]:=input^;i:=i+1;
get(input);end;gfname[i]:=' ';end;{:72}{73:}begin initialize;dialog;
{44:}openpkfile;opengffile{:44};
{49:}if pkbyte<>247 then begin writeln(output,' ',
'Bad pk file!  pre command missing.');jumpout;end;gfbyte(247);
if pkbyte<>89 then begin writeln(output,' ',
'Wrong version of packed file!.');jumpout;end;gfbyte(131);j:=pkbyte;
for i:=1 to j do hppp:=pkbyte;gfbyte(17);
for i:=1 to 17 do gfbyte(xord[comment[i]]);designsize:=get32;
checksum:=get32;hppp:=get32;vppp:=get32;
if hppp<>vppp then writeln(output,'Warning:  aspect ratio not 1:1!');
magnification:=round(hppp*72.27*5/65536);lasteoc:=gfloc{:49};
skipspecials;while flagbyte<>245 do begin{47:}dynf:=flagbyte div 16;
flagbyte:=flagbyte mod 16;turnon:=flagbyte>=8;
if turnon then flagbyte:=flagbyte-8;
if flagbyte=7 then{52:}begin packetlength:=get32;car:=get32;
endofpacket:=packetlength+pkloc;tfmwidth:=get32;horesc:=get32;
veresc:=get32;cwidth:=get32;cheight:=get32;wordwidth:=(cwidth+31)div 32;
xoff:=get32;yoff:=get32;
end{:52}else if flagbyte>3 then{53:}begin packetlength:=(flagbyte-4)
*65536+get16;car:=pkbyte;endofpacket:=packetlength+pkloc;i:=pkbyte;
tfmwidth:=i*65536+get16;horesc:=get16*65536;veresc:=0;cwidth:=get16;
cheight:=get16;wordwidth:=(cwidth+31)div 32;xoff:=signed16;
yoff:=signed16;end{:53}else{54:}begin packetlength:=flagbyte*256+pkbyte;
car:=pkbyte;endofpacket:=packetlength+pkloc;i:=pkbyte;
tfmwidth:=i*65536+get16;horesc:=pkbyte*65536;veresc:=0;cwidth:=pkbyte;
cheight:=pkbyte;wordwidth:=(cwidth+31)div 32;xoff:=signedbyte;
yoff:=signedbyte;end{:54};
{56:}if(cheight=0)or(cwidth=0)then begin cheight:=0;cwidth:=0;xoff:=0;
yoff:=0;end;minm:=-xoff;if minm<mminm then mminm:=minm;
maxm:=cwidth+minm;if maxm>mmaxm then mmaxm:=maxm;minn:=yoff-cheight+1;
maxn:=yoff;if minn>maxn then minn:=maxn;if minn<mminn then mminn:=minn;
if maxn>mmaxn then mmaxn:=maxn{:56};{60:}begin i:=car mod 256;
if(charpointer[i]=-1)then begin sveresc[i]:=veresc;shoresc[i]:=horesc;
stfmwidth[i]:=tfmwidth;
end else begin if(sveresc[i]<>veresc)or(shoresc[i]<>horesc)or(stfmwidth[
i]<>tfmwidth)then writeln(output,'Two characters mod ',i:1,
' have mismatched parameters');end;end{:60};
{59:}begin if(charpointer[car mod 256]=-1)and(car>=0)and(car<256)and(
maxm>=0)and(maxm<256)and(maxn>=0)and(maxn<256)and(maxm>=minm)and(maxn>=
minn)and(maxm<minm+256)and(maxn<minn+256)then begin charpointer[car mod
256]:=thischarptr;gfbyte(68);gfbyte(car);gfbyte(maxm-minm);gfbyte(maxm);
gfbyte(maxn-minn);gfbyte(maxn);end else begin gfbyte(67);gfquad(car);
gfquad(charpointer[car mod 256]);charpointer[car mod 256]:=thischarptr;
gfquad(minm);gfquad(maxm);gfquad(minn);gfquad(maxn);end;end{:59};
{65:}if(cwidth>0)and(cheight>0)then begin bitweight:=0;
countdown:=cheight*cwidth-1;if dynf=14 then turnon:=getbit;
repeatcount:=0;xtogo:=cwidth;ytogo:=cheight;curn:=cheight;count:=0;
firston:=turnon;turnon:=not turnon;rcp:=0;
while ytogo>0 do begin if count=0 then{64:}begin turnon:=not turnon;
if dynf=14 then begin count:=1;done:=false;
while not done do begin if countdown<=0 then done:=true else if(turnon=
getbit)then count:=count+1 else done:=true;countdown:=countdown-1;end;
end else count:=pkpackednum;end{:64};if rcp=0 then firston:=turnon;
while count>=xtogo do begin rowcounts[rcp]:=xtogo;count:=count-xtogo;
for i:=0 to repeatcount do begin{66:}if(rcp>0)or firston then begin j:=0
;max:=rcp;if not turnon then max:=max-1;
if curn-ytogo=1 then begin if firston then gfbyte(74)else if rowcounts[0
]<165 then begin gfbyte(74+rowcounts[0]);j:=j+1;end else gfbyte(70);
end else if curn>ytogo then begin if curn-ytogo<257 then begin gfbyte(71
);gfbyte(curn-ytogo-1);end else begin gfbyte(72);gf16(curn-ytogo-1);end;
if firston then gfbyte(0);end else if firston then gfbyte(0);
curn:=ytogo;
while j<=max do begin if rowcounts[j]<64 then gfbyte(0+rowcounts[j])else
if rowcounts[j]<256 then begin gfbyte(64);gfbyte(rowcounts[j]);
end else begin gfbyte(65);gf16(rowcounts[j]);end;j:=j+1;end;end{:66};
ytogo:=ytogo-1;end;repeatcount:=0;xtogo:=cwidth;rcp:=0;
if(count>0)then firston:=turnon;end;
if count>0 then begin rowcounts[rcp]:=count;
if rcp=0 then firston:=turnon;rcp:=rcp+1;
if rcp>maxcounts then begin writeln(output,
'A character had too many run counts');jumpout;end;xtogo:=xtogo-count;
count:=0;end;end;end{:65};gfbyte(69);lasteoc:=gfloc;
if endofpacket<>pkloc then begin writeln(output,' ',
'Bad pk file!  Bad packet length.');jumpout;end{:47};skipspecials;end;
while not eof(pkfile)do i:=pkbyte;{68:}j:=gfloc;gfbyte(248);
gfquad(lasteoc);gfquad(designsize);gfquad(checksum);gfquad(hppp);
gfquad(vppp);gfquad(mminm);gfquad(mmaxm);gfquad(mminn);gfquad(mmaxn);
{61:}for i:=0 to 255 do if charpointer[i]<>-1 then begin if(sveresc[i]=0
)and(shoresc[i]>=0)and(shoresc[i]<16777216)and(shoresc[i]mod 65536=0)
then begin gfbyte(246);gfbyte(i);gfbyte(shoresc[i]div 65536);
end else begin gfbyte(245);gfbyte(i);gfquad(shoresc[i]);
gfquad(sveresc[i]);end;gfquad(stfmwidth[i]);gfquad(charpointer[i]);
end{:61};gfbyte(249);gfquad(j);gfbyte(131);for i:=0 to 3 do gfbyte(223);
while gfloc mod 4<>0 do gfbyte(223){:68};
writeln(output,pkloc:1,' bytes unpacked to ',gfloc:1,' bytes.');
9999:end.{:73}
